Internet Surfer: Getting Started/Internet Surfer - Getting Started (Wayzata Technology)(7231)(1995).bin/pc/mac/bonus/peter_le/macbinar/task.uni

Text File | 1992-11-23 | 17KB | 658 lines

unit Tasks;

{        Task Manager -- Background processing support}
{        version 2.2.1}

{    This software source package is Copyright ⌐ 1990-91 by Michael Hecht. All Rights}
{    Reserved. It may be freely distributed in source or object code format; however,}
{    the source code may not be sold for profit or charged for in any way. The source}
{    code must be distributed as a package including all H files, sample code and}
{    projects, and documentation.}

{    I welcome any comments or suggestions that will help me improve or extend the}
{    functionality of the Task Manager. You can reach me at:}

{        Internet:        [e-mail]}
{        AppleLink:        SAS.HECHT}

{    Happy Tasking!}

{    --Michael Hecht}

{        Pascal Conversion by Peter N Lewis <[e-mail]>, Aug 1992 }

interface

    const
{ Globals }
        CurStackBaseA = $908;
        HeapEndA = $114;
        WindowListA = $9D6;

{ Define the following constant as true to include stack checking code }
{ Define the following constant as false to remove stack checking code }
        TASK_DEBUG = false;

{ Default options }
        kDefaultWakeTime = 60;            { One second }

    type
        longPtr = ^longInt;

{ Task procedure }
    type
        TaskProcPtr = ProcPtr;
{ procedure TaskProc(taskRefCon:longInt) }

    procedure CallTaskProc (taskRefCon: longInt; p: TaskProcPtr);
    inline
        $205F, $4E90;


{ Routines }
    function InitTasking: OSErr;
    function TermTasking: OSErr;

{ Creating tasks }
    function NewTask (taskProc: TaskProcPtr; taskTermProc: TaskProcPtr; taskRefCon: univ longInt; var taskRefNum: integer): OSErr;
    function DisposeTask (taskRefNum: integer): OSErr;

{ Running tasks }
    function RunTasks (wakeTime: longInt): OSErr;
    function TaskYield: OSErr;

{ Getting task info }
    function CurrentTask: integer;
    function CountTasks: integer;
    function GetIndTask (index: integer): integer;

{ Task reference constant }
    function GetTaskRefCon (taskRefNum: integer): longInt;
    function SetTaskRefCon (taskRefNum: integer; taskRefCon: longInt): OSErr;

implementation

    type
        jmp_buf = record { preserve D2 as well! }
                d2, d3, d4, d5, d6, d7, a1, a2, a3, a4, a6, a7: longInt;
            end;

    function setjmp (var regs: jmp_buf): integer;
    inline
        $205F, $7000, $43FA, $0006, $48D0, $DEFC, $3E80;

    procedure longjmp (var regs: jmp_buf; status: integer);
    inline
        $301F, $205F, $4CD8, $DEFC, $4ED1;

    function GetRegD2: Ptr;
    inline
        $2E82;

    procedure SetRegD2 (n: univ ptr);
    inline
        $241F;

    type
        TaskEnvironmentRecord = record
                envRegisters: jmp_buf;
                envStack: handle;
            end;
        TaskEnvironmentPtr = ^TaskEnvironmentRecord;

{ Register ordering within the jmp_buf }
        regs = (d3, d4, d5, d6, d7,{}
            a1, a2, a3, a4, a6, a7);

        TaskRecord = record
                taskProc: TaskProcPtr;
                taskTermProc: TaskProcPtr;
                taskRefCon: longInt;
                taskRefNum: integer;
                taskEnvironment: TaskEnvironmentRecord;
                taskFlags: longInt;
            end;
        TaskPtr = ^TaskRecord;

{ Values for gTaskMgrFlags }
    type
        TaskMgrFlags = set of (useTempMem, tasksRunning);

{ Return values from setjmp; negative values are OSErr's }
    const
        SJsaveEnvironment = 0;
        SJtaskResume = 1;
        SJtaskSuspend = 2;

    type
        TaskList = record
                numTasks: integer;
                theTask: array[0..100] of TaskRecord;
            end;
        TaskListPtr = ^TaskList;
        TaskListHandle = ^TaskListPtr;

    var
        gTaskList: TaskListHandle;
        gTaskAtHand: integer;
        gCurrentTask: TaskRecord;
        gNextTaskRefNum: integer;
        gTaskMgrFlags: TaskMgrFlags;
        gAppEnvironment: TaskEnvironmentRecord;
        gTimeToStop: longInt;
        CurStackBase: longInt;

    function SizeOfTaskList (n: integer): longInt;
    begin
        SizeOfTaskList := sizeof(integer) + n * sizeof(TaskRecord);
    end;

    function InitTasking: OSErr;
        var
            err: OSErr;
            response, tempMask: longInt;
            CurStackBaseP: longPtr;
    begin
        CurStackBaseP := longPtr(CurStackBaseA);
        CurStackBase := CurStackBaseP^;

        { Allocate the task list }
        gTaskList := TaskListHandle(NewHandle(SizeOfTaskList(0)));
        if gTaskList = nil then begin
            err := MemError;
        end
        else begin

    { Initialize global data }
            gTaskAtHand := -1;                { Run task 0 first }
            gTaskList^^.numTasks := 0;
            gNextTaskRefNum := 1;
            gTaskMgrFlags := [];

    { Determine if temporary memory is available }
            if Gestalt(gestaltOSAttr, response) = noErr then begin
                if BTST(response, gestaltTempMemSupport) and BTST(response, gestaltRealTempMemory) and BTST(response, gestaltTempMemTracked) then
                    gTaskMgrFlags := gTaskMgrFlags + [useTempMem];
            end;
            err := noErr;
        end;

        InitTasking := err;
    end;

    function TermTasking: OSErr;
        var
            err: OSErr;
            taskIndex: integer;
    begin

    { Can't terminate from a task }
        if tasksRunning in gTaskMgrFlags then begin
            err := paramErr;
        end
        else begin
{     *    Kill all tasks. We do this from back to front because it's more}
{     *    efficient, for two reasons:}
{     *}
{     *    Ñ    Less memory gets moved when we shrink the task list.}
{     *}
{     *    Ñ    The taskIndexes are looked up much faster when starting at}
{     *        the end of the list.}

            err := noErr;
            for taskIndex := gTaskList^^.numTasks - 1 downto 0 do begin

                err := DisposeTask(gTaskList^^.theTask[taskIndex].taskRefNum);
                if err <> noErr then
                    leave;
            end;

{ Dispose of the task list }
            DisposHandle(Handle(gTaskList));
            gTaskList := nil;
        end;
        TermTasking := err;
    end;

    function CountTasks: integer;
    begin
        CountTasks := gTaskList^^.numTasks;
    end;

    function CurrentTask: integer;
    begin
        if tasksRunning in gTaskMgrFlags then
            CurrentTask := gCurrentTask.taskRefNum
        else
            CurrentTask := 0;
    end;

    function GetIndTask (index: integer): integer;
    begin
        if (index < 0) or (index >= gTaskList^^.numTasks) then
            GetIndTask := 0
        else
            GetIndTask := gTaskList^^.theTask[index].taskRefNum;
    end;

    function GetTaskIndex (taskRefNum: integer): integer;
        var
            taskIndex: integer;
    begin

{     *    Since taskRefNums start at 1 and always increase, we can assume that}
{     *    the taskIndex will always be less than the taskRefNum or the number of}
{     *    tasks, which ever is smallest. This makes a good starting point in our}
{     *    search for the task.}


        taskIndex := gTaskList^^.numTasks;
        if taskRefNum < taskIndex then
            taskIndex := taskRefNum;
        taskIndex := taskIndex - 1;

        while taskIndex >= 0 do begin
            if gTaskList^^.theTask[taskIndex].taskRefNum = taskRefNum then
                leave;
            taskIndex := taskIndex - 1;
        end;

    { Note that a negative value will be returned if the task isn't found }
        GetTaskIndex := taskIndex;
    end;

    function GetTaskRefCon (taskRefNum: integer): longInt;
        var
            taskIndex: integer;
    begin
        taskIndex := GetTaskIndex(taskRefNum);
        if taskIndex < 0 then begin
            GetTaskRefCon := 0;
        end
        else begin
            GetTaskRefCon := gTaskList^^.theTask[taskIndex].taskRefCon;
        end;
    end;

    function SetTaskRefCon (taskRefNum: integer; taskRefCon: longInt): OSErr;
        var
            taskIndex: integer;
    begin
        taskIndex := GetTaskIndex(taskRefNum);
        if taskIndex < 0 then begin
            SetTaskRefCon := paramErr;
        end
        else begin
            gTaskList^^.theTask[taskIndex].taskRefCon := taskRefCon;
            SetTaskRefCon := noErr;
        end;
    end;

    function AllocStack (var theEnvironment: TaskEnvironmentRecord; stackSize: Size): OSErr;
        var
            err: OSErr;
    begin
    { Has the stack already been allocated? }
        if theEnvironment.envStack <> nil then begin

        { Try to reallocate it }
            ReallocHandle(theEnvironment.envStack, stackSize);
            if MemError = noErr then begin
                AllocStack := noErr;
                exit(AllocStack);
            end;

        { Dispose of the stack and try allocating a whole new one }
            DisposHandle(theEnvironment.envStack);
        end;

    { Try temporary memory first }
        if useTempMem in gTaskMgrFlags then begin

            theEnvironment.envStack := TempNewHandle(stackSize, err);
            if err = noErr then begin
                AllocStack := noErr;
                exit(AllocStack);
            end;
        end;

    { If that didn't work, try allocating from the heap }
        theEnvironment.envStack := NewHandle(stackSize);
        AllocStack := MemError;
    end;

    function SaveEnvironment (theEnvironment: TaskEnvironmentPtr): OSErr;
        var
            err: OSErr;
            status: OSErr;
            stackPtr: Ptr;
            stackSize: Size;
    begin
 { preserve the environment ptr across the stack switch }
{$PUSH}
{$D-}
        SetRegD2(theEnvironment);
    { Save the registers }
        status := setjmp(theEnvironment^.envRegisters);
        theEnvironment := TaskEnvironmentPtr(GetRegD2);
{$POP}
        if status <> SJsaveEnvironment then begin

        { Restore the stack }
            stackSize := GetHandleSize(theEnvironment^.envStack);
            BlockMove(theEnvironment^.envStack^, ptr(CurStackBase - stackSize), stackSize);
            HPurge(theEnvironment^.envStack);
            err := status;
        end
        else begin

    { Allocate the stack }
            stackPtr := Ptr(theEnvironment^.envRegisters.a7);
            stackSize := CurStackBase - ord(stackPtr);
            err := AllocStack(theEnvironment^, stackSize);
            if err = noErr then begin
    { Save the stack }
                BlockMove(stackPtr, theEnvironment^.envStack^, stackSize);
            end;
        end;
        SaveEnvironment := err;
    end;

    procedure RestoreEnvironment (theEnvironment: TaskEnvironmentPtr; status: OSErr);
        var
            HeapEndP: longPtr;
            peek: WindowPeek;
            msg, title: Str255;
            WindowListP: ^windowPeek;
    begin
        HeapEndP := longPtr(HeapEndA);
    { Can't let the stack cross into the heap! }
        if theEnvironment^.envRegisters.a7 < HeapEndP^ then begin
            if TASK_DEBUG then begin
                DebugStr('TaskMgr: Stack overflow');
                ExitToShell;
            end
            else begin
                SysError(28);
            end;
        end;

        if TASK_DEBUG then begin
    { Look for windows in the stack and warn about them }
            WindowListP := POINTER(WindowListA);
            peek := WindowListP^;
            while peek <> nil do begin
                if ord(peek) >= HeapEndP^ then begin
                    GetWTitle(windowPtr(peek), title);
                    DebugStr(concat('TaskMgr: Window in stack: ', title));
                    ExitToShell;
                end;
                peek := peek^.nextWindow;
            end;
        end;

    { Restore the registers }
        longjmp(theEnvironment^.envRegisters, status);
    end;

    procedure StartNextTask;
    begin
    { Move to next task at hand }
        gTaskAtHand := gTaskAtHand + 1;
        if gTaskAtHand >= gTaskList^^.numTasks then
            gTaskAtHand := 0;

    { Keep gCurrentTask up-to-date }
        gCurrentTask := gTaskList^^.theTask[gTaskAtHand];

    { Start the next task }
        RestoreEnvironment(@gCurrentTask.taskEnvironment, SJtaskResume);

    { This statement should never be hit }
        DebugStr('TaskMgr/StartNextTask: returned from RestoreEnvironment!?!?');
    end;


    function RunTasks (wakeTime: longInt): OSErr;
        var
            status: OSErr;
    begin

        if TASK_DEBUG then begin
    { Called from task? }
            if tasksRunning in gTaskMgrFlags then begin
                DebugStr('TaskMgr/RunTasks: Called from task');
                RunTasks := paramErr;
                exit(RunTasks);
            end;
        end;

    { Nothing to do if no tasks to run }
        if gTaskList^^.numTasks = 0 then begin
            RunTasks := noErr;
            exit(RunTasks);
        end;

    { Determine when to stop running tasks }
        gTimeToStop := TickCount;
        gTimeToStop := gTimeToStop + wakeTime;

    { Save application's state }
        status := SaveEnvironment(@gAppEnvironment);
        case status of
            SJsaveEnvironment:  begin
        { We just saved the application's environment; time to start next task }
                StartNextTask;
        { StartNextTask never returns }
            end;

            SJtaskSuspend:  begin
        { Tasks have suspended execution; time to return to the application }
                status := noErr;
            end;
            otherwise begin
        { Anything else is an OSErr code }

        { This case will be hit if SaveEnvironment couldn't }
                if TASK_DEBUG then
                    DebugStr('TaskMgr/RunTasks: Can''t save environment');
            end;
        end;

        RunTasks := status;
    end;

    function TaskYield: OSErr;
        var
            taskAtHand: integer;
            status: OSErr;
            timeToSuspend: Boolean;
            theEvent: EventRecord;
    begin

        if TASK_DEBUG then begin
    { Called from application? }
            if not (tasksRunning in gTaskMgrFlags) then begin
                DebugStr('TaskMgr/TaskYield: Called from application');
                TaskYield := paramErr;
                exit(TaskYield);
            end;
        end;

{     *    Determine if it's time to return to the application.}
{     *}
{     *    It's that time if the wake time has run out or if the application}
{     *    received an event.}

        timeToSuspend := (TickCount >= gTimeToStop) or EventAvail(everyEvent, theEvent);

{ if it's not time to suspend and I'm the only task, then I'll just keep running }
        if not timeToSuspend and (gTaskList^^.numTasks = 1) then begin
            TaskYield := noErr;
            exit(TaskYield);
        end;

    { Save the current task's environment }
        status := SaveEnvironment(@gCurrentTask.taskEnvironment);

    { Return to the task }
        if status <> SJsaveEnvironment then begin

            if status > noErr then begin
                status := noErr

        { A negative status is an OSErr }
            end
            else if TASK_DEBUG then begin
                DebugStr('TaskMgr/TaskYield: Can''t save environment');
            end;

        { Tasks are running now }
            gTaskMgrFlags := gTaskMgrFlags + [tasksRunning];

            TaskYield := status;
            exit(TaskYield);
        end;

    { Put the saved environment in the task list }
        gTaskList^^.theTask[gTaskAtHand].taskEnvironment := gCurrentTask.taskEnvironment;

    { If it's time to return to the application, then do so }
        if timeToSuspend then begin

        { Tasks no longer running }
            gTaskMgrFlags := gTaskMgrFlags - [tasksRunning];

        { Return to the application }
            RestoreEnvironment(@gAppEnvironment, SJtaskSuspend);
        end;

    { Start the next task }
        StartNextTask;
    end;

    function DisposeTask (taskRefNum: integer): OSErr;
        var
            taskIndex: integer;
            dyingTask: TaskRecord;
            harakiri: Boolean;
            dummy: longInt;
    begin

        taskIndex := GetTaskIndex(taskRefNum);
        if taskIndex < 0 then begin
            DisposeTask := paramErr;
            exit(DisposeTask);
        end;

    { Are we deleting the current task? }
        harakiri := (tasksRunning in gTaskMgrFlags) and (taskIndex = gTaskAtHand);

    { Point to the task record of the task we're disposing }
        dyingTask := gTaskList^^.theTask[taskIndex];

    { If the task has a term proc, call it now }
        if dyingTask.taskTermProc <> nil then
            CallTaskProc(dyingTask.taskRefCon, dyingTask.taskTermProc);

    { We can dispose of its stack now }
        DisposHandle(dyingTask.taskEnvironment.envStack);

    { Remove the task from the task list }
        dummy := Munger(Handle(gTaskList), SizeOfTaskList(taskIndex), nil, sizeof(TaskRecord), @gTaskList, 0);

    { Fix up task at hand if necessary }
        if gTaskAtHand >= taskIndex then begin
            gTaskAtHand := gTaskAtHand - 1;
            if gTaskAtHand < 0 then begin
                gTaskAtHand := gTaskList^^.numTasks;
            end;
        end;

    { One less task to keep track of }
        gTaskList^^.numTasks := gTaskList^^.numTasks - 1;

    { Return to the application if we deleted ourselves }
        if harakiri then begin

        { Tasks are no longer running (we will be returning to the application) }
            gTaskMgrFlags := gTaskMgrFlags - [tasksRunning];
            RestoreEnvironment(@gAppEnvironment, SJtaskSuspend);
        end;

    { Not disposing of ourselves; return to the caller }
        DisposeTask := noErr;
    end;

    procedure TaskLife;
        var
            oe: OSErr;
    begin
    { TaskLife is the task's life cycle }

    { We are now running a task }
        gTaskMgrFlags := gTaskMgrFlags + [tasksRunning];

    { Call the task procedure }
        CallTaskProc(gCurrentTask.taskRefCon, gCurrentTask.taskProc);

    { Delete the task }
        oe := DisposeTask(gCurrentTask.taskRefNum);
    end;

    function NewTask (taskProc: TaskProcPtr; taskTermProc: TaskProcPtr; taskRefCon: univ longInt; var taskRefNum: integer): OSErr;
        var
            err: OSErr;
            status: OSErr;
            saveTask: TaskRecord;
    begin

    { Make a backup copy of the current task }
        saveTask := gCurrentTask;

    { Initialize the task record }
        gCurrentTask.taskProc := taskProc;
        gCurrentTask.taskTermProc := taskTermProc;
        gCurrentTask.taskRefCon := taskRefCon;
        gNextTaskRefNum := gNextTaskRefNum + 1;
        gCurrentTask.taskRefNum := gNextTaskRefNum;
        gCurrentTask.taskFlags := 0;
        gCurrentTask.taskEnvironment.envStack := nil;

    { Give task refNum back to caller }
        taskRefNum := gCurrentTask.taskRefNum;

    { Initialize the task's environment }
        status := SaveEnvironment(@gCurrentTask.taskEnvironment);
        if status < noErr then begin
            err := status;
        end
        else begin

            if status > SJsaveEnvironment then begin
                TaskLife;
        { Never to return╔ }
            end;

    { Add task to task list }
            err := PtrAndHand(@gCurrentTask, Handle(gTaskList), sizeof(TaskRecord));
            if err <> noErr then begin

        { Dispose of the stack }
                DisposHandle(gCurrentTask.taskEnvironment.envStack);

        { Not enough memory to add it to the task list }
            end
            else begin
                gTaskList^^.numTasks := gTaskList^^.numTasks + 1;

    { All dressed up and nowhere to go }
                err := noErr;
            end;
        end;

        gCurrentTask := saveTask;
        NewTask := err;
    end;

end.